perm filename SLURZ.F4[NEW,LCS]7 blob sn#552722 filedate 1980-12-17 generic text, type T, neo UTF8
C***** SLURZ -- NREST (FOR BEAMS)

	SUBROUTINE SLURZ
	INTEGER UPDN
	COMMON R2,JAZ,CENTR,JBZ,RJQ(20),JQ(20) /STF/RSTFAC(8),RSTJ2
	1 /XRN/RN(1) /PTR/KWDS(1)
	1 /RINP/R(10,85),POSNT(0/99) /RMOD/RMODE2,SET4,IBEAM,
	1 NOSET,STEM,STUP,NTC,PS2,RAM,RDD,IT,POS /ALF/INP(72),ML
	1 /LIMIT/LIMIT,ITEM,LL,IS,IX 
	1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
	1 /SCX/JALPHA(7),ISTAR,JAL(22),JX,U,JZ,IRHY,JD,KA,KB,IZ
	1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
	1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA

251	INVT=-1
	LS=IS
C SAVE PTR TO RN ARRAY FOR SLUR FEATURE AT 614 (AND TREM. FEATURE)
	JNTC=NTC-1
C  JNTC=NUM OF NTS NOW
125	IF(REND.NE.0)GO TO 25
	REND=3
25	CALL XREAD

C  *******  1ST MAIN LOOP *********
	JMP=1
505	L=0
	K=0
	POS=-10.
	RN(8+IS)=0
	RN(9+IS)=0
	IT=0
	UPDN=0
C  UPDN=2=STEMS DOWN, (SLUR DIP UP)  =1, OPPOSITE.
104	JA=J+1
	B=VX(JA)
C THE 2ND NOTE (-=DIP DOWN ALWAYS; +100=UP ALWAYS, ORD.=AUTOMATIC)
	IF(B.LT.100)GO TO 512
	UPDN=2
	B=B-100
	IF(B.GT.100)B=100-B
C  TYPE -NUM OR 200+NUM FOR DIP DOWN.
	VX(JA)=B
512	IF(B)UPDN=1
	RN(9+IS)=0
	BRK=AMOD(VX(J),1.)*10.
	IF(BRK.EQ.0)GO TO 503
C ADDS NUM TO BRACK. OR BEAM. ADD DESIRED .NUM TO 1ST NUM.(1.3=3)
	RN(9+IS)=BRK+.0001
	GO TO 5030
503	IF(N.GT.0)GO TO 5031
	IT=-1
	CALL SLEND
C  -1= SLUR INTO 1ST NOTE.
C  SETS POS OF LFT SIDE (-10+9, THEN +2)
	GO TO 5060
5031	IF(N.LE.JNTC)GO TO 5030
C  JNTC=NUM OF REAL NTS+1
	CALL SLEND
C  SLEND CHECKS ON END POINTS OF THIS STAFF
	GO TO 504
C  -1=1ST SLUR FROM NO NOTE; 99= LAST, TO NO NOTE
5032	IF(N.LE.JNTC)GO TO 5030
	N=JNTC  
C TRAPS ERROR OF TRYING TO PUT MARK ON NON-EXISTENT NOTE.
	VX(J)=N
C VX(J)=N IS NEEDED AT LABEL 130  
5030	L=L+1
502	K=K+1
	IF(R(1,K).NE.1.)GO TO 502
C  IS IT A NOTE?
	P=R(3,K)
	IF(P.EQ.POS)GO TO 502
C  SKIPS DBLSTPS
	POS=P
506	IF(L.LT.N)GO TO 5030
C  NOW SLUR STARTS
5060	IF(JMP)GO TO 504
C  JMP=-1 MEANS END NOTE OF GROUP
	J=J+1
	NN=VX(J)
C  IF 2ND NUM IS .LE. 1ST , THEN 2-NOTE SLUR. (-1 GOES TO 1)
	IF(NN.EQ.0)NN=N+1
	IF(NN.EQ.0)NN=1
	IF(NN)GO TO 777
	IF(NN.LE.N)NN=N+1
C  FOR USE WITH AUTO-BEAMS OR DIP UP.  2-NOTE SLUR OR BEAM UP.
777	CONTINUE
5061	MK=N
	N=IABS(NN)
	M=K
	JA=3
	JB=4
	KN=K
	RB=0
	IBR=6
C  6=SLUR, 7=BRACK. FOR TRIPLETS, ETC.
CC*** NOT NEEDED NOW WITH UPDN FEATURE.	IF(STEM.GE.0)NN=-NN
	IF(IT)GO TO 550
C  IT=-1=SLUR INTO 1ST NOTE.
	A=XNOTE(K)
C XNOTE IS AMOD(R(4,K),100.)
C  SAVES LEVEL OF 1ST NOTE.
504	RB=2
	IF(NN)RB=-RB
C  DIP IS SET BY PARAM 7. (STEM DIR. IS AUTOMATIC)
550	RN(JA+IS)=POS
	B=XNOTE(K)
	SLUR=0
C A FLAG FOR LATER USE.
	JA=K
	IF(JA.NE.0)GO TO 451
1451	JA=JA+1
	IF(R(1,JA).NE.1)GO TO 1451
451	MB=R(5,JA)/10.
	IF(MB.NE.0)GO TO 450
	MB=1
	X=R(4,JA)
	IF(X.GT.80)X=X-100
	IF(X.GT.6)MB=2
450	IF(UPDN.EQ.0)GO TO 515
	IF(MB.EQ.UPDN)GO TO 515
	X=6
	IF(NN)X=-X
	RB=RB+X
	JA=3
	IF(JMP)JA=6
	IF(NN)GO TO 204
	IF(UPDN.EQ.2)GO TO 516
204	IF(UPDN.EQ.1)GO TO 516
C  ABOVE FOR VARIOUS COMBINATIONS OF STEM DIRECTIONS
	RB=-RB
	NN=-NN
516	IF(K.GT.1)GO TO 16
	IF(IT)GO TO 513
16	IF(K.NE.JNTC)GO TO 116
	IF(N.GT.JNTC)GO TO 513
C JUMP IF N=99, BY PASS IF K IS NOT LAST NOTE OF LINE.
116	SLUR=0.5
	IF(UPDN.EQ.1)SLUR=-SLUR
	SLUR=SLUR*RSTJ2
	RN(JA+IS)=RN(JA+IS)+SLUR
C  THIS NOT DONE IF SLUR TO FIRST NOTE
	GO TO 513
517	IF(MB.EQ.1)GO TO 513
	IF(RB)RB=-RB
	GO TO 518
515	UPDN=MB
C AUTO SLUR DIP DEPENDS ON STEM DIREC. OF 1ST NOTE. (WHOLE NTS??)
	IF(NN)GO TO 517
	IF(MB.NE.1)GO TO 513
	RB=-RB
518	NN=-NN
513	RN(JB+IS)=B+RB
C  MK=# OF 1ST NOTE, N=END NOTE NOW
	JMP=-JMP
	IF(JMP.GT.0)GO TO 1503
C  GO FIND RT. SIDE OF SLUR
	JA=6
	JB=5
	IF(N.LE.MK)N=MK+1
C  PICKS UP TYPO ERRORS
	JK=0
	IF(R(7,K).GE.10)JK=-1
C  CHECKS FOR DOT AFTER 1ST NOTE -- FOR TIES.
	GO TO 503

1503	RN(2+IS)=STAFF

5503	RN(8+IS)=-1
	RN(1+IS)=5
	IF(IT)RN(4+IS)=RN(5+IS)
	NN=-NN
C  IF NN IS NEG. NOW IT MEANS STEM DOWN.(DIP IS UP!)
	IF(N.EQ.99)GO TO 200
C TYPE /n 99/ FOR SLUR BEYOND NOTE HEAD (TO DIFF. PITCH ON NEXT LINE)
C /n x/ IS TIE TO SAME NOTE ON NEXT LINE. (X IS ANY NUMBER > LAST NOTE NUM.)
	IF(MK.EQ.-99)GO TO 200
C TYPE /-99 n/ FOR SLUR FROM DIFF. NOTE ON PREVIOUS LINE.
C  /0 n/ OR /-1 n/ IS TIE FROM SAME NOTE, PREV. LINE
	C=0
C C WILL BE FLAG IN SECTION ON TIES BETWEEN CHORDS (AT 114)
	AA=XNOTE(K)
	IF(MK.EQ.JNTC)GO TO 61
C JNTC (NOTE COUNT) THE LAST NOTE(OR CHORD) OF INPUT
	IF(N.EQ.1)GO TO 61
	IF(IT)GO TO 2114
	IF(N-MK.GT.1)GO TO 2114
C  M=1ST NOTE OF SLUR, K=LAST
	B=R(5,K)
	IF(AMOD(B,10.0).GT.0)GO TO 65
C  JUMP IF LAST NOTE HAS ACCI.
C  JUMP IF NOT ADJACENT NOTE AT SAME PITCH AND NOT 1ST OR LAST.
C  JUMP IF SLUR IS VERY SHORT
	IF(AA.EQ.A)GO TO 61
C NEXT FOR NOTES AT DIFFERENT LEVELS
	IF(B.LT.20)GO TO 161
C ARE STEMS THE SAME DIRECTION. JUMP OUT IF SO.
	IF(R(5,M).GE.20)GO TO 2114
	GO TO 61
161	IF(R(5,M).LT.20)GO TO 2114
61	IF(IT)A=AA
C  IT=-1=SLUR INTO 1ST NOTE.
	C=6
	IF(JK)C=8
	JB=6+IS
	C=RN(JB)-RN(3+IS)-C*RSTJ2
CATCHES VERY SHORT SLURS - OR 1ST NOTE HAS 2 OR MORE TAILS (PUTS SLUR ABOVE)
	IF(AMOD(R(7,M),10.0).GE.2.)C=-1
	B=-.7
	IF(C.OR.A.NE.AA)B=-1.8
	IF(NN)B=-B
C  TO RAISE OR LOWER IT .7
C12/80	RN(4+IS)=A+B
C12/80	RN(5+IS)=AA+B
	RA=A+B
	RB=AA+B
C JB = 6+IS
	CALL SLRLEV(RA,RB,NN,C,RN(JB))
C  RA=LEFT LEVEL OF SLUR, RB=RIGHT LEVEL, NN=NEG=SLUR 'DIP' IS UP
	RN(4+IS)=RA
	RN(5+IS)=RB
C ABOVE LINES FOR SLURS WHEN STEMS GO OPPOSITE DIRECTIONS.
	B=-2
	IF(JK)B=-3
C  JK=-1 WHEN NOTE IS DOTTED.
C THIS PUTS TIE BETWEEN (NOT ABOVE OR BELOW) NTS. NO STEM CHNG.
	IF(C)B=-1
	RN(8+IS)=B
	IF(SLUR.EQ.0)GO TO 65
	RN(3+IS)=RN(3+IS)-SLUR
	RN(JB)=RN(JB)-SLUR
C  PUSH SLUR BACK TO WHERE IT WAS
	GO TO 65

C NEXT TO SHIFT SLUR IN RE. TO MARKS. STAC., TEN., ACC.
C ***********KN = 1ST NOTE, K=LAST NOTE.********
2114	JA=KN
	JB=4
2503	RB=R(2,JA)
	IF(RB.EQ.0)GO TO 3503
	IF(BRK.NE.0)GO TO 6503
C IS IT A BRACKET INSTEAD OF A SLUR?
	IF(RB.EQ.4.OR.RB.EQ.5)GO TO 4503
	IF(RB.NE.7.AND.RB.NE.9)GO TO 3503
6503	RB=1.5
 	IF(R(5,JA).LT.20)RB=-RB
	RN(IS+JB)=RN(IS+JB)+RB
	GO TO 3503
4503	L=R(9,JA)
C THE POINTER TO P11 WAS SAVED HERE BY 'NEWR'
	RN(L)=RN(L)+.2
3503	IF(JA.EQ.K)GO TO 200
CC3503	IF(JA.EQ.K)GO TO 60
	JA=K
	JB=JB+1
	GO TO 2503

CC60	IF(STEM.GE.0)GO TO 200
C  JUMP IF SLURS**************
62	IF(NN)GO TO 64
	IF(A.EQ.DMAX)GO TO 65
	AA=B-DMAX
	GO TO 63
65	AA=0
	GO TO 63
64	IF(A.EQ.UMAX)GO TO 65
	AA=UMAX-B
63	RA=RN(6+IS)
	RB=RN(3+IS)
	RN(7+IS)=0
C ABOVE FOR FUNCTION RCURVE.  RN(7+IS)=X LATER ON.
  	X=RCURVE(RN(3+IS))
CC	X=0.9+(RA-RB)/25.+ABS(RN(4+IS)-RN(5+IS))/10.
C  CURVE DEPENDS ON LENGTH, TILT AND NOTES BETWEEN.
	IF(AA.GT.0)X=X+AA*.5
	IF(BRK.EQ.0)GO TO 66
	RN(8+IS)=1
	RN(3+IS)=RB-.6
CC**********	RB=R(3,K+1)
C  K=END NOTE OF GROUP
CC**********	IF(K.EQ.IZ)RB=200.
C IZ IS LAST ITEM IN R(N,M)
CXXXX	IF(K.EQ.IRHY)RB=200.
C  ASSUMES LINE STOPS AT 200. (IT COULD BE LONGER!!)
	RN(6+IS)=RA+4*RSTJ2   
C PUT RIGHT END OF BRACKET A LITTLE BEYOND LAST NOTE.
CC**********	RN(6+IS)=RA+(RB-RA)/2.
	IBR=7
C  CHECK THESE NUMBERS↑↑↑↑
	B=RN(4+IS)
	BB=RN(5+IS)
	RA=1
	IF(A.LT.-1)RA=2.5
C  CHANGES HEIGHT.  MAKES BRACK. IF N>100.
	IF(NN.GT.0)RA=-RA
	RN(4+IS)=B+RA
	RN(5+IS)=BB+RA
	X=2
66	IF(NN.GT.0)X=-X
510	RN(7+IS)=X

2514	L=IS
	CALL UPDATE(IBR)
	IF(C.EQ.0)GO TO 514
C JUMP OUT IF INTERVENING NOTE.   C≠0 = TIE BETWEEN NOTES
	IF(RN(L+4).NE.RN(L+5))GO TO 514
C  IS IT LEVEL?
	IF(BRK.NE.0)GO TO 514
C JUMP OUT IF A BRACKET
	B=-RN(IS-2)
C CHANGE DIRECTION OF DIP AFTER FIRST SLUR.
	D=.7
	IF(RN(L+8).EQ.-1)D=D+1.3
CZ 	RA=.7
CZ	IF(RN(L+8).EQ.-1)RA=RA+1.3
C  IS TIE NOT BETWEEN NOTES?
	IF(NN.GT.0)D=-D
CZ	IF(NN.GT.0)RA=-RA
C DIP DIRECTION.  NN+ =DOWN, NN- =UP.  REVERSED AFTER 1ST ONE.
	C=-2.
	IF(RN(L+8).EQ.-3.)C=-3.
C PUT TIE BETWEEN NOTES ALWAYS.

	JA=M
	JB=K
	IF(MK)JA=JB
C FOR TIES TO 1ST OF LINE
	IF(N.GT.JNTC)JB=JA
C FOR END OF LINE CHORDS   JNTC=TOTAL OF NOTES (NOTE COUNT)
	RC=R(3,JA)
114	JA=JA+1
	JB=JB+1
	IF(RC.NE.R(3,JA))GO TO 514
C JUMP IF RIGHT-HAND NOTE NOT IN SAME POS.
	IF(R(1,JA).NE.1)GO TO 514
C  CATCHES THINGS BETWEEN NOTES
	IF(R(4,JA).NE.R(4,JB))GO TO 514
C  LOOKS FOR  PARALLEL CHORDS NOTES
	A=XNOTE(JA)
	BB=D
CZ	BB=RA
	IF(AMOD(A,2.0).EQ.0)BB=BB/2.
C MOVE SLUR 1/2  IF IT WOULD LAND ON A SPACE (EVEN NUMS).
	A=A-BB
CF	RN(IS)=6.
CF	RN(IS+1)=5.
CF	RN(IS+2)=RN(IS-7)
CF	RN(IS+3)=RN(IS-6)
CF	RN(IS+6)=RN(IS-3)
CF	RN(IS+7)=B
CF	RN(IS+8)=C
CF	RN(IS+4)=A  
CF	RN(IS+5)=A  
	CALL RNX(6.,5.,RN(IS-7),RN(IS-6),A,A,RN(IS-3),B,C)
	CALL UPDATE(IBR)
	GO TO 114

514	J=J+1
	A=VX(J)
	N=A
C  SO ITEMS NEED NOT BE IN RIGHT ORDER.
	IF(MOD(N,100).GT.IRHY)A=0
	IF(A.NE.0)GO TO 505
CC***USE NO NUMBS IN COMMENTS IN MODE 3-5******	IF(VX(J+2).EQ.0)GO TO 614
	IF(J.LT.50)GO TO 514
C  SOMETIMES A SLASH IS SEEN AS A 0 (WHEN PRECEDED BY SPACE).
614	IF(INP(72).NE.ISTAR)GO TO  552

C NEXT FOR TWO SLURS ON SAME POS. LOOKS AT LEFT SIDE FIRST.
	NS=LS
	MB=LS
C INITIALIZE MB IN CASE IT SKIPS PAST 814.
C NEXT ARE PARAMS 4, 3, 6 OF SLUR.  2ND TIME AROUND USE 5, 6, 3.
	N=4
	NA=3
	NB=6
1314	IF(RN(LS+8).LT.-1)GO TO 1014
C SKIP OUT IF SLUR IS IN BETWEEN NOTES (P8=-2 OR -3)
	JS=LS
	X=1.8
	IF(RN(LS+7))X=-X
	A=RN(LS+NA)
	B=RN(LS+NB)
C A AND B ARE THE TWO HORIZ. POSITIONS.  RA IS HEIGHT.
	RA=RN(LS+N)
814	MB=RN(JS)+JS+3
C MB IS THE NEXT SLUR
	IF(MB.LT.IS)GO TO 1514
	LS=RN(LS)+LS+3
C MOVE AHEAD ONE SLUR
	IF(LS.GE.IS)GO TO 1214
	GO TO 1314
1514	IF(RN(MB+8).LT.-1)GO TO 1014
	IF(A.NE.RN(MB+NA))GO TO 1014
	D=RN(MB+NB)
C MAYBE PUT IN SOMETHING HERE TO CATCH SLURS WITH OPPOSITE DIPS.
	JB=MB
	IF(N.EQ.5)GO TO 1414
	IF(B.GT.D)JB=LS
	GO TO 1114
1414	IF(D.GT.B)JB=LS
1114	BB=RN(N+JB)
	IF(ABS(BB-RA).LT.0.5)RN(N+JB)=BB+X
C SHIFT HEIGHT OF SLUR ONLY IF HEIGHT IS CURRENTLY THE SAME. 
1014	JS=MB
	GO TO 814
1214	IF(N.EQ.5)GO TO 714
C START AGAIN, LOOK AT RIGHT END OF SLURS NOW
	N=N+1
	NA=6
	NB=3
	LS=NS
	GO TO 1314

714	IF(INVT)RETURN
	INVT=IS
 	CALL NEWR
	IS=INVT
	RETURN
552	CALL BMREAD
C  TO READ MORE THAN 2 LINES.
	GO TO 25
200	M=KN
	JMAX=0
	IF(N-MK.EQ.1)JMAX=-1
207	L=M+1
	IF(R(1,L).NE.1)GO TO 307
	IF(R(5,L).GE.10)GO TO 307
	M=M+1
	GO TO 207
C  FOR HEIGHTS OF DBL STPS, ETC.
307	CONTINUE
607	A=XNOTE(M)
C   A=NOTE 1.
	UMAX=A
	DMAX=A
C  UP MAX. NOTE #, DOWN MAX. NOTE #.
407	M=K+1
	IF(R(1,M).NE.1)GO TO 103
	IF(R(5,M).GE.10)GO TO 103
C  FINDS DBL+ STP ON LAST OF BEAM
	IF(R(6,M))GO TO 103
C JUMP OUT IF A WHITE NOTE
	K=M
	GO TO 407
CX103	IF(STEM.EQ.0)GO TO 603
CX	MMS=R(5,KN)/10.
CX	DO 703 M=KN+1,K
CX703	IF(MMS.NE.IFIX(R(5,M)/10.))GO TO 4
C SKIP NEXT IF STEMS ARE SPECIFIED IN DIFF. DIRECTIONS. (GRACE NTS??)
CX603	DO 3 M=KN,K
103	DO 3 M=KN,K
	IF(R(1,M).NE.1)GO TO 3
CXCXCX	IF(STEM.NE.0.AND.R(10,M).NE.0)GO TO 3
C SKIP NOTES ON OTHER STAFF
	IF(M.EQ.K)GO TO 107
	IF(R(1,M+1).NE.1)GO TO 107
C IT ONLY CARES ABOUT NOTES!
	IF(R(5,M+1).LT.10)GO TO 3
C IGNORE LOWER (OR UPPER) NOTES OF CHORDS (NO STEM)-IN RE. UP-DOWN FEATURE.
CC107	IF(MB)GO TO 7
C  SKIP IF DEALING WITH GRACE NOTE BEAMS. (MB=-1)
107	IF(ABS(R(4,M)).GE.100)GO TO 3
C  SKIPS NON-NOTES
7	B=XNOTE(M)
55	IF(B.LT.UMAX)GO TO 13
	UMAX=B
	IF(JMAX)GO TO 3
	IF(M.EQ.KN)GO TO 3
	IF(M.EQ.K)GO TO 3
	UMAX=UMAX+1
	GO TO 3
13	IF(B.GT.DMAX)GO TO 3
	DMAX=B
	IF(JMAX)GO TO 3
	IF(M.EQ.KN)GO TO 3
	IF(M.EQ.K)GO TO 3
	DMAX=DMAX-1
3	CONTINUE
C  LOOKS FOR LOWER AND HIGHER NOTES THAN NOTE 1.
4	GO TO 62
	END

	FUNCTION NREST(K)
COUNTS REST FROM START OF LINE UP TO ITEM K-1 (K IS A NOTE)
	COMMON /SCM/V(1)
	NREST=0
	DO 1 J=1,K-1
1	IF(V(J))NREST=NREST+1
	END